home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / graphics.swg / 0019_Graphic FX Unit.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-08-27  |  41.5 KB  |  1,903 lines
  1. {
  2. I hope you can do something With these listings
  3. I downloaded from a BBS near me....
  4. This File contains:  Program VGA3d
  5.                      Unit DDFigs
  6.                      Unit DDVars
  7.                      Unit DDVideo
  8.                      Unit DDProcs
  9. Just break it in pieces on the cut here signs......
  10.  
  11. if you need some Units or Programs (or TxtFiles) on Programming the Adlib/
  12. Sound-Blaster or Roland MPU-401, just let me know, and i see if i can dig
  13. up some good listings.....
  14. But , will your game also have Soundblaster/adlib fm support and Sound
  15. Blaster Digitized Sound support, maybe even MPU/MT32? support....
  16. And try to make it as bloody as you can (Heads exploding etc..)(JOKE)
  17.  
  18. I hope i you can complete your game (i haven't completed any of my games yet)
  19. And i like a copy of it when it's ready......
  20.  
  21. Please leave a message if you received this File.
  22.  
  23.   Andre Jakobs
  24.     MicroBrain Technologies Inc.
  25.         GelderlandLaan 9
  26.           5691 KL   Son en Breugel
  27.             The Netherlands............
  28. }
  29.  
  30.  
  31. Program animatie_van_3d_vector_grafics;
  32.  
  33. Uses
  34.   Crt,
  35.   ddvideo,
  36.   ddfigs,
  37.   ddprocs,
  38.   ddVars;
  39.  
  40. Var
  41.   Opal : paletteType;
  42.  
  43. Procedure wireframe(pro : vertex2Array);
  44. { Teken een lijnen diagram van gesloten voorwerpen met vlakken }
  45. Var
  46.   i, j, k,
  47.   v1, v2  : Integer;
  48. begin
  49.   For i :=  1 to ntf DO
  50.   begin
  51.     j := nfac[i];
  52.     if j <> 0 then
  53.     begin
  54.       v1 := faclist[ facfront[j] + size[j] ];
  55.       For k :=  1 to size[j] DO
  56.       begin
  57.         v2 := faclist[facfront[j] + k];
  58.         if (v1<v2) or (super[i] <> 0 ) then
  59.           linepto(colour[j], pro[v1], pro[v2])
  60.         v1 := v2;
  61.       end;
  62.     end;
  63.   end;
  64. end;
  65.  
  66. Procedure hidden(pro : vertex2Array);
  67. { Display van Objecten als geheel van de projectiepunten van pro }
  68. { b is een masker voor de kleuren }
  69. Var
  70.   i,  col : Integer;
  71.  
  72.   Function signe( n : Real) : Integer;
  73.   begin
  74.     if n >0 then
  75.       signe := -1
  76.     else
  77.     if n <0 then
  78.       signe := 1
  79.     else
  80.       signe := 0;
  81.   end;
  82.  
  83.   Function orient(f : Integer; v : vertex2Array) : Integer;
  84.   Var
  85.     i, ind1,
  86.     ind2, ind3 : Integer;
  87.     dv1, dv2   : vector2;
  88.   begin
  89.     i := nfac[f];
  90.     if i = 0 then
  91.       orient := 0
  92.     else
  93.     begin
  94.       ind1   := faclist[facfront[i] + 1];
  95.       ind2   := faclist[facfront[i] + 2];
  96.       ind3   := faclist[facfront[i] + 3];
  97.       dv1.x  := v[ind2].x - v[ind1].x;
  98.       dv1.y  := v[ind2].y - v[ind1].y;
  99.       dv2.x  := v[ind3].x - v[ind2].x;
  100.       dv2.y  := v[ind3].y - v[ind2].y;
  101.       orient := signe(dv1.x * dv2.y - dv2.x * dv1.y);
  102.     end;
  103.   end;
  104.  
  105.   Procedure facetfill(k : Integer);
  106.   Var
  107.     v           : vector2Array;
  108.     i, index, j : Integer;
  109.   begin
  110.     j := nfac[k];
  111.     For i :=  1 to size[j] DO
  112.     begin
  113.       index := faclist[facfront[j] + i];
  114.       v[i]  := pro[index];
  115.     end;
  116.     fillpoly(colour[k], size[j], v);
  117.     polydraw(colour[k] - 1, size[j], v);
  118.   end;
  119.  
  120.   Procedure seefacet(k : Integer);
  121.   Var
  122.     ipt, supk : Integer;
  123.   begin
  124.     facetfill(k);
  125.     ipt := firstsup[k];
  126.     While ipt <> 0 DO
  127.     begin
  128.       supk := facetinfacet[ipt].info;
  129.        facetfill(supk);
  130.       ipt := facetinfacet[ipt].Pointer;
  131.     end;
  132.   end;
  133.  
  134. { hidden Programmacode }
  135. begin
  136.   For i := 1 to nof DO
  137.   if super[i] = 0 then
  138.     if orient(i, pro) = 1 then
  139.       seefacet(i);
  140. end;
  141.  
  142. Procedure display;
  143. Var
  144.   i : Integer;
  145. begin
  146.   {observe}
  147.   For i := 1 to nov DO
  148.     transform(act[i], Q, obs[i]);
  149.  
  150.   {project}
  151.   ntv := nov;
  152.   ntf := nof;
  153.   For i := 1 to ntv DO
  154.   begin
  155.     pro[i].x := obs[i].x;
  156.     pro[i].y := obs[i].y;
  157.   end;
  158.  
  159.   {drawit}
  160.   switch := switch xor 1;
  161.   hidden(pro);
  162.   Scherm_actief(switch);
  163.   Virscherm_actief(switch xor 1);
  164.   wisscherm(prevpoints, $a000, $8a00);
  165.   wis_hline(prevhline, $8a00);
  166.   prevpoints := points;prevhline := hline;
  167.   points[0]  := 0;
  168.   hline[0]   := 0;
  169. end;
  170.  
  171. Procedure anim3d;
  172. Var
  173.   A, B, C, D, E, F,
  174.   G, H, I, J, QE, P    : matrix4x4;
  175.   zoom, inz, inzplus   : Real;
  176.   angle, angleinc,
  177.   beta, betainc, frame : Integer;
  178.   huidigpalette        : paletteType;
  179.  
  180.   { Kubus Animatie : Roterende kubus }
  181.   Procedure kubus;
  182.   begin
  183.     angle    := 0;
  184.     angleinc := 9;
  185.     beta     := 0;
  186.     betainc  := 2;
  187.     direct.x := 9;
  188.     direct.y := 2;
  189.     direct.z := -3;
  190.     findQ;
  191.     cubesetup(104);
  192.     frame := 0;
  193.  
  194.     While (NOT (KeyPressed)) and (frame < 91) do
  195.     begin
  196.       frame   := frame + 1;
  197.       xyscale := zoom * 2 * sinus(beta);
  198.       rot3(1, trunc(angle/2), Qe);
  199.       rot3(2, angle, P);
  200.       mult3(P, Qe, P);
  201.       cube(P);
  202.       display;
  203.       angle := angle + angleinc;
  204.       beta  := beta + betainc;
  205.       nov   := 0;
  206.     end;
  207.   end;
  208.  
  209.   {Piramides Animatie : Scene opgebouwd uit twee Piramides en 1 Kubus }
  210.   Procedure Piramides;
  211.   begin
  212.     frame   := 0;
  213.     angle   := 0;
  214.     beta    := 0;
  215.     betainc := 2;
  216.     scale3(4.0, 0.2, 4.0, C);
  217.     cubesetup(90);
  218.     cube(P);
  219.  
  220.     scale3(2.5, 4.0, 2.5, D);
  221.     tran3(2.0, -0.2, 2.0, E);
  222.     mult3(E, D, F);
  223.     pirasetup(34);
  224.     piramid(P);
  225.  
  226.     scale3(2.0, 4.0, 2.0, G);
  227.     tran3(-3.0, -0.2, 0.0, H);
  228.     mult3(H, G, I);
  229.     pirasetup(42);
  230.     piramid(P);
  231.  
  232.     E := Q;
  233.     nov := 0;
  234.  
  235.     While (NOT (KeyPressed)) and (frame < 18) do
  236.     begin
  237.       frame   := frame + 1;
  238.       xyscale := zoom * 2 * sinus(beta);
  239.  
  240.       rot3(2, angle, B);
  241.  
  242.       mult3(B, C, P);
  243.       cube(P);
  244.  
  245.       mult3(B, F, P);
  246.       piramid(P);
  247.  
  248.       mult3(B, I, P);
  249.       piramid(P);
  250.  
  251.       display;
  252.  
  253.       angle := angle + angleinc;
  254.       beta  := beta + betainc;
  255.       nov   := 0;
  256.      end;
  257.  
  258.      frame := 0;
  259.      angleinc := 7;
  260.  
  261.      While (NOT (KeyPressed)) and (frame < 75) do
  262.      begin
  263.        frame := frame + 1;
  264.  
  265.        rot3(2, angle, B);
  266.  
  267.        mult3(B, C, P);
  268.        cube(P);
  269.  
  270.        mult3(B, F, P);
  271.        piramid(P);
  272.  
  273.        mult3(B, I, P);
  274.        piramid(P);
  275.  
  276.        display;
  277.  
  278.        angle := angle + angleinc;
  279.        nov   := 0;
  280.      end;
  281.  
  282.      frame := 0;
  283.      beta := 180-beta;
  284.  
  285.      While (NOT (KeyPressed)) and (frame < 19) do
  286.      begin
  287.  
  288.        frame := frame + 1;
  289.  
  290.        xyscale := zoom * 2 * sinus(beta);
  291.        rot3(2, angle, B);
  292.  
  293.        mult3(C, B, P);
  294.        cube(P);
  295.  
  296.        mult3(B, F, P);
  297.        piramid(P);
  298.  
  299.        mult3(B, I, P);
  300.        piramid(P);
  301.  
  302.        display;
  303.  
  304.        angle := angle + angleinc;
  305.        beta  := beta  + betainc;
  306.        nov   := 0;
  307.     end;
  308.   end;
  309.  
  310.   { Huis_animatie4 : Figuur huis roteert en "komt uit de lucht vallen" }
  311.   Procedure huisval;
  312.   begin
  313.     xyscale  := zoom;
  314.     nof      := 0;
  315.     nov      := 0;
  316.     last     := 0;
  317.     angle    := 1355;
  318.     angleinc := -7;
  319.     frame    := 0;
  320.  
  321.     huissetup;
  322.  
  323.     zoom     := 0.02;
  324.     Direct.x := 30;
  325.     direct.y := -2;
  326.     direct.z := 30;
  327.     findQ;
  328.  
  329.     While (NOT (KeyPressed)) and (frame < 40) do
  330.     begin
  331.       frame := frame + 1;
  332.       zoom  := zoom + 0.01;
  333.       Scale3(zoom, zoom, zoom, Qe);
  334.       tran3(0, (-7 / zoom) + frame / 1.8, 0, A);
  335.       mult3(Qe, A, C);
  336.       rot3(2, angle, B);
  337.       mult3(C, B, P);
  338.       huis(P);
  339.       display;
  340.       angle := angle + angleinc;
  341.       nov   := 0;
  342.     end;
  343.  
  344.     frame   := 0;
  345.     beta    := angle;
  346.     betainc := angleinc;
  347.  
  348.     While (NOT (KeyPressed)) and (frame < 15) do
  349.     begin
  350.       frame := frame + 1;
  351.  
  352.       rot3(2, beta, B);
  353.       mult3(B, Qe, P);
  354.       mult3(P, A, P);
  355.       huis(P);
  356.  
  357.       display;
  358.  
  359.       beta    := beta + betainc;
  360.       betainc := trunc(betainc + (7 / 15));
  361.       nov     := 0;
  362.     end;
  363.  
  364.     frame := 0;
  365.  
  366.     While (NOT (KeyPressed)) and (frame < 30) do
  367.     begin
  368.       frame    := frame + 1;
  369.       direct.z := direct.z - (frame * (20 / 70));
  370.       findQ;
  371.       huis(P);
  372.       display;
  373.       nov := 0;
  374.     end;
  375.  
  376.     frame := 0;
  377.     zoom  := 1;
  378.  
  379.     While (NOT (KeyPressed)) and (frame < 31) do
  380.     begin
  381.       frame := frame + 1;
  382.       mult3(B, Qe, P);
  383.       scale3(zoom, zoom, zoom, C);
  384.       mult3(P, A, P);
  385.       mult3(P, C, P);
  386.       huis(P);
  387.       display;
  388.       zoom := zoom - 1 / 30;
  389.       nov  := 0;
  390.     end;
  391.  
  392.     zoom := xyscale;
  393.   end;
  394.  
  395.   { Ster Animatie : Roterende ster als kubus met 4 piramides }
  396.   Procedure Sterrot;
  397.   begin
  398.     xyscale  := zoom;
  399.     frame    := 0;
  400.     angle    := 0;
  401.     angleinc := 9;
  402.     beta     := 0;
  403.     betainc  := 2;
  404.     nof      := 0;
  405.     last     := 0;
  406.     nov      := 0;
  407.  
  408.     stersetup(140);
  409.     scale3(0, 0, 0, P);
  410.     ster(P, 4);
  411.  
  412.     Direct.x := 30;
  413.     direct.y := -2;
  414.     direct.z := 30;
  415.     findQ;
  416.     E := Q;
  417.  
  418.     While (NOT (KeyPressed)) and (frame < 90) do
  419.     begin
  420.       frame   := frame + 1;
  421.       xyscale := zoom * 1.7 * sinus(beta);
  422.       rot3(1, Round(angle/5), A);
  423.       mult3(A, E, Q);
  424.       rot3(2, angle, P);
  425.       ster(P, 4);
  426.       display;
  427.       angle := angle + angleinc;
  428.       beta  := beta  + betainc;
  429.       nov   := 0;
  430.     end;
  431.   end;
  432.  
  433. begin
  434.   eye.x := 0;
  435.   eye.y := 0;
  436.   eye.z :=  0;
  437.   zoom  := xyscale;
  438.   Repeat
  439.     nov  := 0;
  440.     nof  := 0;
  441.     last := 0;
  442.     Kubus;
  443.     Piramides;
  444.     Huisval;
  445.     Sterrot;
  446.   Until KeyPressed;
  447. end;
  448.  
  449. { _______________Hoofd Programma --------------------- }
  450.  
  451. begin
  452.   nov  := 0;
  453.   nof  := 0;
  454.   last := 0;
  455.   start('pira', 15,  Opal);
  456.  
  457.   points[0]     := 0;
  458.   prevpoints[0] := 0;
  459.   hline[0]      := 0;
  460.   prevhline[0]  := 0;
  461.  
  462.   anim3D;
  463.  
  464.   finish(Opal);
  465.   Writeln('Coded by ...... " De Vectorman "');
  466.   Writeln;
  467. end.
  468.  
  469.  
  470. { ▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒ }
  471.  
  472. Unit ddfigs;
  473.  
  474. Interface
  475.  
  476. Uses
  477.   DDprocs, DDVars;
  478.  
  479. Const
  480.   cubevert : Array [1..8] of vector3 =
  481.     ((x :  1; y :  1; z :  1),
  482.      (x :  1; y : -1; z :  1),
  483.      (x :  1; y : -1; z : -1),
  484.      (x :  1; y :  1; z : -1),
  485.      (x : -1; y :  1; z :  1),
  486.      (x : -1; y : -1; z :  1),
  487.      (x : -1; y : -1; z : -1),
  488.      (x : -1; y :  1; z : -1));
  489.  
  490.   cubefacet : Array [1..6, 1..4] of Integer =
  491.     ((1, 2, 3, 4),
  492.      (1, 4, 8, 5),
  493.      (1, 5, 6, 2),
  494.      (3, 7, 8, 4),
  495.      (2, 6, 7, 3),
  496.      (5, 8, 7, 6));
  497.  
  498.   piravert  : Array [1..5] of vector3 =
  499.     ((x :  0; y :  1; z :  0),
  500.      (x :  1; y :  0; z : -1),
  501.      (x : -1; y :  0; z : -1),
  502.      (x : -1; y :  0; z :  1),
  503.      (x :  1; y :  0; z :  1));
  504.  
  505.   pirafacet : Array [1..5, 1..3] of Integer =
  506.     ((1, 2, 3),
  507.      (1, 3, 4),
  508.      (1, 4, 5),
  509.      (1, 5, 2),
  510.      (5, 4, 3));
  511.  
  512.   huisvert  : Array[1..59] of vector3 =
  513.     ((x : -6; y :  0; z :  4), (x :  6; y : 0; z :  4),
  514.      (x :  6; y :  0; z : -4),
  515.      (x : -6; y :  0; z : -4), (x : -6; y : 8; z :  4), (x :  6; y : 8; z :  4),
  516.      (x :  6; y : 11; z :  0), (x :  6; y : 8; z : -4), (x : -6; y : 8; z : -4),
  517.      (x : -6; y : 11; z :  0), (x : -4; y : 1; z :  4), (x : -1; y : 1; z :  4),
  518.      (x : -1; y :  3; z :  4), (x : -4; y : 3; z :  4), (x : -4; y : 5; z :  4),
  519.      (x : -1; y :  5; z :  4), (x : -1; y : 7; z :  4), (x : -4; y : 7; z :  4),
  520.      (x :  0; y :  0; z :  4), (x :  5; y : 0; z :  4), (x :  5; y : 4; z :  4),
  521.      (x :  0; y :  4; z :  4), (x :  1; y : 5; z :  4), (x :  4; y : 5; z :  4),
  522.      (x :  4; y :  7; z :  4), (x :  1; y : 7; z :  4), (x :  6; y : 5; z : -1),
  523.      (x :  6; y :  5; z : -3), (x :  6; y : 7; z : -3), (x :  6; y : 7; z : -1),
  524.      (x :  5; y :  1; z : -4), (x :  2; y : 1; z : -4), (x :  2; y : 3; z : -4),
  525.      (x :  5; y :  3; z : -4), (x :  5; y : 5; z : -4), (x :  2; y : 5; z : -4),
  526.      (x :  2; y :  7; z : -4), (x :  5; y : 7; z : -4), (x :  1; y : 0; z : -4),
  527.      (x : -1; y :  0; z : -4), (x : -1; y : 3; z : -4), (x :  0; y : 4; z : -4),
  528.      (x :  1; y :  3; z : -4), (x : -2; y : 1; z : -4), (x : -5; y : 1; z : -4),
  529.      (x : -5; y :  3; z : -4), (x : -2; y : 3; z : -4), (x : -2; y : 5; z : -4),
  530.      (x : -5; y :  5; z : -4), (x : -5; y : 7; z : -4), (x : -2; y : 7; z : -4),
  531.      (x : -6; y :  0; z :  1), (x : -6; y : 0; z :  3), (x : -6; y : 3; z :  3),
  532.      (x : -6; y :  3; z :  1), (x : -6; y : 5; z :  1), (x : -6; y : 5; z :  3),
  533.      (x : -6; y :  7; z :  3), (x : -6; y : 7; z :  1));
  534.  
  535.   huissize  : Array [1..19] of Integer =
  536.     (4, 4, 5, 4, 4, 5, 4, 4, 4, 4, 4, 4, 4, 4, 5, 4, 4, 4, 4);
  537.  
  538.   huissuper : Array [1..19] of Integer =
  539.     (0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 3, 4, 4, 4, 4, 4, 6, 6);
  540.  
  541.   huisfacet : Array [1..79] of Integer =
  542.     ( 1,  2,  6,  5,
  543.       5,  6,  7, 10,
  544.       2,  3,  8,  7,
  545.       6,  3,  4,  9,
  546.       8,  8,  9, 10,
  547.       7,  4,  1,  5,
  548.      10,  9,  4,  3,
  549.       2,  1, 11, 12,
  550.      13, 14, 15, 16,
  551.      17, 18, 19, 20,
  552.      21, 22, 23, 24,
  553.      25, 26, 27, 28,
  554.      29, 30, 31, 32,
  555.      33, 34, 35, 36,
  556.      37, 38, 39, 40,
  557.      41, 42, 43, 44,
  558.      45, 46, 47, 48,
  559.      49, 50, 51, 52,
  560.      53, 54, 55, 56,
  561.      57, 58, 59);
  562.  
  563.   stervert : Array [1..6] of vector3 =
  564.     ((x :  1; y :  0; z :  0),
  565.      (x :  0; y :  1; z :  0),
  566.      (x :  0; y :  0; z :  1),
  567.      (x :  0; y :  0; z : -1),
  568.      (x :  0; y : -1; z :  0),
  569.      (x : -1; y :  0; z :  0));
  570.  
  571. Procedure cubesetup(c : Integer);
  572. Procedure cube(P : matrix4x4);
  573. Procedure pirasetup(c : Integer);
  574. Procedure piramid(P : matrix4x4);
  575. Procedure huissetup;
  576. Procedure huis(P : matrix4x4);
  577. Procedure hollow(P1 : matrix4x4);
  578. Procedure stersetup(col : Integer);
  579. Procedure ster(P : matrix4x4; d : Real);
  580. Procedure ellips(P : matrix4x4; col : Integer);
  581. Procedure goblet(P : matrix4x4; col : Integer);
  582.  
  583. Implementation
  584.  
  585. Procedure cubesetup(c : Integer);
  586. { zet kubusdata in facetlist van de scene}
  587. Var
  588.   i, j : Integer;
  589. begin
  590.   For i :=  1 to 6 DO
  591.   begin
  592.     For j := 1 to 4 DO
  593.       faclist[last + j] := cubefacet[i, j] + nov;
  594.     nof := nof + 1;
  595.     facfront[nof] := last;
  596.     colour[nof]   := c;
  597.     nfac[nof]     := nof;
  598.     super[nof]    := 0;
  599.     firstsup[nof] := 0;
  600.     size[nof]     := 4;
  601.     last := last + size[nof];
  602.   end;
  603. end;
  604.  
  605. Procedure cube(P : matrix4x4);
  606. Var
  607.   i, j : Integer;
  608. begin
  609.   For i :=  1 to 8 DO
  610.   begin
  611.     nov := nov + 1;
  612.     transform(cubevert[i], P, act[nov]);
  613.   end;
  614. end;
  615.  
  616. Procedure pirasetup(c : Integer);
  617. Var
  618.   i, j : Integer;
  619. begin
  620.   For i :=  1 to 5 DO
  621.   begin
  622.     For j := 1 to 3 DO
  623.       faclist[last + j] := pirafacet[i, j] + nov;
  624.     nof := nof + 1;
  625.     facfront[nof] := last;
  626.     size[nof]     := 3;
  627.     last          := last + size[nof];
  628.     colour[nof]   := c;
  629.     nfac[nof]     := nof;
  630.     super[nof]    := 0;
  631.     firstsup[nof] := 0;
  632.   end;
  633.  
  634.   size[nof] := 4;
  635.   faclist[facfront[nof] + 4] := 2 + nov;
  636.   last := last + 1;
  637. end;
  638.  
  639. Procedure piramid(P : matrix4x4);
  640. Var
  641.   i, j : Integer;
  642. begin
  643.   For i :=  1 to 5 DO
  644.   begin
  645.     nov := nov + 1;
  646.     transform(piravert[i], P, act[nov]);
  647.   end;
  648. end;
  649.  
  650.  
  651. Procedure huissetup;
  652. Var
  653.   i, j,
  654.   host,
  655.   nofstore : Integer;
  656. begin
  657.   For i := 1 to 79 DO
  658.     faclist[last + i] := huisfacet[i] + nov;
  659.  
  660.   nofstore := nof;
  661.  
  662.   For i := 1 to 19 DO
  663.   begin
  664.     nof           := nof + 1;
  665.     facfront[nof] := last;
  666.     size[nof]     := huissize[i];
  667.     last          := last + size[nof];
  668.     nfac[nof]     := nof;
  669.  
  670.     if (i = 2) or (i = 5) then
  671.       colour[nof] := 111
  672.     else
  673.     if i = 7 then
  674.       colour[nof] := 20
  675.     else
  676.     if i < 8 then
  677.       colour[nof] := 42
  678.     else
  679.       colour[nof] := 25;
  680.  
  681.     super[nof] := huissuper[i];
  682.     firstsup[nof] := 0;
  683.  
  684.     if super[nof] <> 0 then
  685.     begin
  686.       host := super[nof] + nofstore;
  687.       super[nof] := host;
  688.       pushfacet(firstsup[host], nof);
  689.     end;
  690.   end;
  691.   For i  :=  1 to 59 DO
  692.     setup[i] := huisvert[i];
  693. end;
  694.  
  695. Procedure huis(P : matrix4x4);
  696. Var
  697.   i : Integer;
  698. begin
  699.   For i := 1 to 59 DO
  700.   begin
  701.     nov := nov + 1;
  702.     transform(setup[i], P, act[nov]);
  703.   end;
  704. end;
  705.  
  706.  
  707. Procedure hollow(P1 : matrix4x4);
  708. Var
  709.   A, B,
  710.   P, P2 : matrix4x4;
  711.   i     : Integer;
  712. begin
  713.   For i := 1 to 8 DO
  714.   begin
  715.     tran3(4.0 * cubevert[i].x, 4.0 * cubevert[i].y, 4.0 * cubevert[i].z, P2);
  716.     mult3(P1, P2, P);
  717.     cube(P);
  718.   end;
  719.  
  720.   For i := 1 to 4 DO
  721.   begin
  722.     scale3(3.0, 1.0, 1.0, A);
  723.     tran3(0.0, 4.0 * cubevert[i].y, 4.0 * cubevert[i].z, B);
  724.     mult3(A, B, P2);mult3(P1, P2, P);
  725.     cube(P);
  726.     scale3(1.0, 3.0, 1.0, A);
  727.     tran3(4.0 * cubevert[i].y, 0.0, 4.0 * cubevert[i].z, B);
  728.     mult3(A, B, P2);mult3(P1, P2, P);
  729.     cube(P);
  730.     scale3(1.0, 1.0, 3.0, A);
  731.     tran3(4.0 * cubevert[i].z, 4.0 * cubevert[i].y, 0.0, B);
  732.     mult3(A, B, P2);mult3(P1, P2, P);
  733.     cube(P);
  734.   end;
  735. end;
  736.  
  737. Procedure stersetup(col : Integer);
  738. Var
  739.   i, j,
  740.   v1, v2 : Integer;
  741. begin
  742.   For i := 1 to 6 DO
  743.   begin
  744.     v1 := cubefacet[i, 4] + nov;
  745.     For j := 1 to 4 DO
  746.     begin
  747.       v2  := cubefacet[i, j] + nov;
  748.       nof := nof + 1;
  749.       faclist[last + 1] := v1;
  750.       faclist[last + 2] := v2;
  751.       faclist[last + 3] := nov + 8 + i;
  752.       facfront[nof]     := last;
  753.       size[nof] := 3;
  754.  
  755.       last := last + size[nof];
  756.       colour[nof] := col;
  757.       nfac[nof]   := nof;
  758.       super[nof]  := 0;
  759.       firstsup[nof] := 0;
  760.       v1 := v2;
  761.     end;
  762.   end;
  763. end;
  764.  
  765. Procedure ster(P : matrix4x4; d : Real);
  766. Var
  767.   i, j,
  768.   v1, v2 : Integer;
  769.   A, S   : matrix4x4;
  770. begin
  771.   For i :=  1 to 8 DO
  772.   begin
  773.     nov := nov + 1;
  774.     transform(cubevert[i], P, act[nov]);
  775.   end;
  776.  
  777.   scale3(D, D, D, A);
  778.   mult3(A, P, S);
  779.  
  780.   For i := 1 to 6 DO
  781.   begin
  782.     nov := nov + 1;
  783.     transform(stervert[i], S, act[nov]);
  784.   end;
  785. end;
  786.  
  787. Procedure ellips(P : matrix4x4; col : Integer);
  788. Var
  789.   v : vector2Array;
  790.   theta,
  791.   thetadiff,
  792.   i : Integer;
  793. begin
  794.   theta := -90;
  795.   thetadiff := -9;
  796.   For i :=  1 to 21 DO
  797.   begin
  798.     v[i].x := cosin(theta);
  799.     v[i].y := sinus(theta);
  800.     theta  := theta + thetadiff;
  801.   end;
  802.   bodyofrev(P, col, 21, 20, v);
  803. end;
  804.  
  805. Procedure goblet(P : matrix4x4; col : Integer);
  806. Const
  807.   gobletdat : Array [1..12] of vector2 =
  808.     ((x :  0; y : -16),
  809.      (x :  8; y : -16),
  810.      (x :  8; y : -15),
  811.      (x :  1; y : -15),
  812.      (x :  1; y :  -2),
  813.      (x :  6; y :  -1),
  814.      (x :  8; y :   2),
  815.      (x : 14; y :  14),
  816.      (x : 13; y :  14),
  817.      (x :  7; y :   2),
  818.      (x :  5; y :   0),
  819.      (x :  0; y :   0));
  820.  
  821. Var
  822.   gobl : vector2Array;
  823.   i    : Integer;
  824. begin
  825.   For i := 1 to 12 DO
  826.     gobl[i] := gobletdat[i];
  827.   bodyofrev(P, col, 12, 20, gobl)
  828. end;
  829.  
  830. begin;
  831. end.
  832.  
  833.  
  834. { ▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒ }
  835.  
  836. Unit ddprocs;
  837.  
  838. Interface
  839.  
  840. Uses
  841.   DDVars;
  842.  
  843. Const
  844.   maxv = 200;
  845.   maxf = 400;
  846.   maxlist = 1000;
  847.   vectorArraysize  = 32;
  848.   sizeofpixelArray = 3200;
  849.   sizeofhlineArray = 320 * 4;
  850.  
  851. Type
  852.   vector2      = Record x, y : Real; end;
  853.   vector3      = Record x, y, z : Real; end;
  854.   pixelvector  = Record x, y : Integer; end;
  855.   pixelArray   = Array [0..sizeofpixelArray] of Integer;
  856.   hlineArray   = Array [0..sizeofhlineArray] of Integer;
  857.   vector3Array = Array [1..vectorArraysize] of vector3;
  858.   matrix3x3    = Array [1..3, 1..3] of Real;
  859.   matrix4x4    = Array [1..4, 1..4] of Real;
  860.   vertex3Array = Array [1..maxv] of vector3;
  861.   vertex2Array = Array [1..maxv] of vector2;
  862.   vector2Array = Array [1..vectorArraysize ] of vector2;
  863.   facetArray   = Array [1..maxf] of Integer;
  864.   facetlist    = Array [1..maxlist] of Integer;
  865.  
  866. Const
  867.   EenheidsM : matrix4x4 =
  868.     ((1, 0, 0, 0),
  869.      (0, 1, 0, 0),
  870.      (0, 0, 1, 0),
  871.      (0, 0, 0, 1));
  872. Var
  873.   Q           : matrix4x4;
  874.   eye, direct : vector3;
  875.   nov, ntv,
  876.   ntf, nof,
  877.   last        : Integer;
  878.   setup,
  879.   act, obs    : vertex3Array;
  880.   pro         : vertex2Array;
  881.   faclist     : facetlist;
  882.   colour,
  883.   size,
  884.   facfront,
  885.   nfac,
  886.   super,
  887.   firstsup    : facetArray;
  888.   points,
  889.   prevpoints  : pixelArray;
  890.   hline,
  891.   prevhline   : hlineArray;
  892.  
  893. Procedure tran3(tx, ty, tz : Real; Var A : matrix4x4);
  894. Procedure scale3(sx, sy, sz : Real; Var A : matrix4x4);
  895. Procedure rot3(m : Integer; theta : Integer; Var A : matrix4x4);
  896. Procedure mult3(A, B : matrix4x4; Var C : matrix4x4);
  897. Procedure findQ;
  898. Procedure genrot(phi : Integer; b, d : vector3; Var A : matrix4x4);
  899. Procedure transform(v : vector3; A : matrix4x4; Var w : vector3);
  900. Procedure extrude(P : matrix4x4; d : Real; col, n : Integer;
  901.                   v : vector2Array);
  902. Procedure bodyofrev(P : matrix4x4; col, nvert, nhoriz : Integer;
  903.                     v : vector2Array);
  904. Procedure polydraw(c, n : Integer; poly : vector2Array);
  905. Procedure linepto(c : Integer; pt1, pt2 : vector2);
  906. Procedure WisScherm(punten : pixelArray; SchermSeg, VirSeg : Word);
  907. Procedure fillpoly(c, n : Integer; poly : vector2Array);
  908. Procedure Wis_Hline(hline_ar : hlineArray; virseg : Word);
  909.  
  910. Implementation
  911.  
  912. Procedure tran3(tx, ty, tz : Real; Var A : matrix4x4);
  913. { zet matrix A op punt tx, ty, tz }
  914. begin
  915.   A := EenheidsM;
  916.   A[1, 4] := -tx;
  917.   A[2, 4] := -ty;
  918.   A[3, 4] := -tz;
  919. end;
  920.  
  921. Procedure scale3(sx, sy, sz : Real; Var A : matrix4x4);
  922. { zet matrix A om in schaal van sx, sy, sz }
  923. begin
  924.   A := EenheidsM;
  925.   A[1, 1] := sx;
  926.   A[2, 2] := sy;
  927.   A[3, 3] := sz;
  928. end;
  929.  
  930. Procedure rot3(m : Integer; theta : Integer; Var A : matrix4x4);
  931. { roteer matrix A om m: 1=x-as; 2=y-as; 3=z-as met hoek theta (in graden)}
  932. Var
  933.   m1, m2 : Integer;
  934.   c, s   : Real;
  935. begin
  936.   A  := EenheidsM;
  937.   m1 := (m MOD 3) + 1;
  938.   m2 := (m1 MOD 3) + 1;
  939.   c  := cosin(theta);
  940.   s  := sinus(theta);
  941.   A[m1, m1] := c;
  942.   A[m2, m2] := c;
  943.   A[m1, m2] := s;
  944.   A[m2, m1] := -s;
  945. end;
  946.  
  947. Procedure mult3(A, B : matrix4x4; Var C : matrix4x4);
  948. { vermenigvuldigd matrix A en B naar matrix C }
  949. Var
  950.   i, j, k : Integer;
  951.   ab      : Real;
  952. begin
  953.   For i := 1 to 4 do
  954.     For j :=  1 to 4 do
  955.     begin
  956.       ab := 0;
  957.       For k := 1 to 4 do
  958.         ab := ab + A[i, k] * B[k, j];
  959.       C[i, j] := ab;
  960.     end;
  961. end;
  962.  
  963. Procedure findQ;
  964. { Bereken de Observatie-matrix 'Q' voor een punt in de ruimte }
  965. Var
  966.   E, F, G,
  967.   H, U    : matrix4x4;
  968.   alpha,
  969.   beta,
  970.   gamma   : Integer;
  971.   v, w    : Real;
  972. begin
  973.   tran3(eye.x, eye.y, eye.z, F);
  974.  
  975.   alpha := angle(-direct.x, -direct.y);
  976.   rot3(3, alpha, G);
  977.  
  978.   v :=  sqrt( (direct.x * direct.x) + (direct.y * direct.y));
  979.   beta := angle(-direct.z, v);
  980.   rot3(2, beta, H);
  981.  
  982.   w :=  sqrt( (v * v) + (direct.z * direct.z));
  983.   gamma := angle( -direct.x * w,  direct.y * direct.z);
  984.   rot3(3, gamma, U);
  985.  
  986.   mult3(G, F, Q);
  987.   mult3(H, Q, E);
  988.   mult3(U, E, Q);
  989. end;
  990.  
  991. Procedure genrot (phi : Integer; b, d : vector3; Var A : matrix4x4);
  992. Var
  993.   F, G, H,
  994.   W, FI, GI,
  995.   HI, S, T  : matrix4x4;
  996.   v         : Real;
  997.   beta,
  998.   theta     : Integer;
  999. begin
  1000.   tran3(b.x, b.y, b.z, F);
  1001.   tran3(-b.x, -b.y, -b.z, FI);
  1002.   theta := angle(d.x, d.y);
  1003.   rot3(3, theta, G);
  1004.   rot3(3, -theta, GI);
  1005.   v := sqrt(d.x * d.x + d.y * d.y);
  1006.   beta := angle(d.z, v);
  1007.   rot3(2, beta, H);
  1008.   rot3(2, -beta, HI);
  1009.   rot3(2, beta, H);
  1010.   rot3(2, -beta, HI);
  1011.   rot3(3, phi, W);
  1012.   mult3(G, F, S);
  1013.   mult3(H, S, T);
  1014.   mult3(W, S, T);
  1015.   mult3(HI, S, T);
  1016.   mult3(GI, T, S);
  1017.   mult3(FI, S, A);
  1018. end;
  1019.  
  1020. Procedure transform(v : vector3; A : matrix4x4; Var w : vector3);
  1021. { transformeer colomvector 'v' uit A in colomvector 'w'}
  1022. begin
  1023.   w.x := A[1, 1] * v.x + A[1, 2] * v.y + A[1, 3] * v.z + A[1, 4];
  1024.   w.y := A[2, 1] * v.x + A[2, 2] * v.y + A[2, 3] * v.z + A[2, 4];
  1025.   w.z := A[3, 1] * v.x + A[3, 2] * v.y + A[3, 3] * v.z + A[3, 4];
  1026. end;
  1027.  
  1028. Procedure extrude(P : matrix4x4; d : Real; col, n : Integer;
  1029.                   v : vector2Array);
  1030. { Maakt van een 2d-figuur een 3d-figuur }
  1031. { vb: converteert 2d-letters naar 3d-letters }
  1032. Var
  1033.   i, j,
  1034.   lasti : Integer;
  1035.   v3    : vector3;
  1036. begin
  1037.   For i := 1 to n DO
  1038.   begin
  1039.     faclist[last + i] := nov + i;
  1040.     faclist[last + n + i] := nov + 2 * n + 1 - i;
  1041.   end;
  1042.   facfront[nof + 1] := last;
  1043.   facfront[nof + 2] := last + n;
  1044.   size[nof + 1] := n;
  1045.   size[nof + 2] := n;
  1046.   nfac[nof + 1] := nof + 1;
  1047.   nfac[nof + 2] := nof + 2;
  1048.   super[nof + 1] := 0;
  1049.   super[nof + 2] := 0;
  1050.   firstsup[nof + 1] := 0;
  1051.   firstsup[nof + 2] := 0;
  1052.   colour[nof + 1] := col;
  1053.   colour[nof + 2] := col;
  1054.   last  := last + 2 * n;
  1055.   nof   := nof + 2;
  1056.   lasti := n;
  1057.  
  1058.   For i := 1 to n DO
  1059.   begin
  1060.     faclist[last + 1] := nov + i;
  1061.     faclist[last + 2] := nov + lasti;
  1062.     faclist[last + 3] := nov + n + lasti;
  1063.     faclist[last + 4] := nov + n + i;
  1064.     nof := nof + 1 ;
  1065.     facfront[nof] := last;
  1066.     size[nof]     := 4;
  1067.     nfac[nof]     := nof;
  1068.     super[nof]    := 0;
  1069.     firstsup[nof] := 0;
  1070.     colour[nof]   := col;
  1071.     last  := last + 4;
  1072.     lasti := i;
  1073.   end;
  1074.   For i :=  1 To n DO
  1075.   begin
  1076.     v3.x := v[i].x;
  1077.     v3.y := v[i].y;
  1078.     v3.z := 0.0;
  1079.     nov  := nov + 1;
  1080.     transform(v3, P, act[nov]);
  1081.     v3.z := -d;
  1082.     transform(v3, P, act[nov + n]);
  1083.   end;
  1084.   nov := nov + n;
  1085. end;
  1086.  
  1087. Procedure bodyofrev(P : matrix4x4; col, nvert, nhoriz : Integer;
  1088.                     v : vector2Array);
  1089. { maakt een "rond" figuur van een 2-dimensionale omlijning van het figuur }
  1090. Var
  1091.   theta,
  1092.   thetadiff,
  1093.   i, j, newnov : Integer;
  1094.   c, s         : Array [1 .. 100] of Real;
  1095.   index1,
  1096.   index2       : Array [1 .. 101] of Integer;
  1097. begin
  1098.   theta := 0;
  1099.   thetadiff := trunc(360 / nhoriz);
  1100.  
  1101.   For i := 1 to nhoriz DO
  1102.   begin
  1103.     c[i]  := cosin(theta);
  1104.     s[i]  := sinus(theta);
  1105.     theta := theta + thetadiff;
  1106.   end;
  1107.   newnov := nov;
  1108.  
  1109.   if abs(v[1].x) < epsilon  then
  1110.   begin
  1111.     newnov := newnov + 1;
  1112.     setup[newnov].x := 0.0;
  1113.     setup[newnov].y := v[1].y;
  1114.     setup[newnov].z := 0.0;
  1115.     For i := 1 to nhoriz + 1 DO
  1116.       index1[i] := newnov;
  1117.   end
  1118.   else
  1119.   begin
  1120.     For i := 1 to nhoriz DO
  1121.     begin
  1122.       newnov := newnov + 1;
  1123.       setup[newnov].x := v[1].x * c[i];
  1124.       setup[newnov].y := v[1].y;
  1125.       setup[newnov].z := -v[1].x * s[i];
  1126.       index1[i] := newnov;
  1127.     end;
  1128.     index1[nhoriz + 1] := index1[i];
  1129.   end;
  1130.  
  1131.   For j :=  2 to nvert DO
  1132.   begin
  1133.     if abs(v[j].x) < epsilon then
  1134.     begin
  1135.       newnov := newnov + 1;
  1136.       setup[newnov].x := 0.0;
  1137.       setup[newnov].y := v[j].y;
  1138.       setup[newnov].z := 0.0;
  1139.       For i := 1 to nhoriz + 1 DO
  1140.         index2[i] := newnov;
  1141.     end
  1142.     else
  1143.     begin
  1144.       For i := 1 To nhoriz DO
  1145.       begin
  1146.         newnov := newnov + 1;
  1147.         setup[newnov].x :=  v[j].x * c[i];
  1148.         setup[newnov].y :=  v[j].y;
  1149.         setup[newnov].z := -v[j].x * s[i];
  1150.         index2[i] := newnov;
  1151.       end;
  1152.       index2[nhoriz + 1] := index2[1];
  1153.     end;
  1154.  
  1155.     if index1[1] <> index1[2] then
  1156.       if index2[1] = index2[2] then
  1157.       begin
  1158.         For i := 1 to nhoriz DO
  1159.         begin
  1160.           nof := nof + 1; size[nof] := 3;
  1161.           facfront[nof] := last;
  1162.           faclist[last + 1] := index1[i + 1];
  1163.           faclist[last + 2] := index2[i];
  1164.           faclist[last + 3] := index1[i];
  1165.           last := last + size[nof];
  1166.           nfac[nof]     := nof;
  1167.           colour[nof]   := col;
  1168.           super[nof]    := 0;
  1169.           firstsup[nof] := 0;
  1170.         end;
  1171.       end
  1172.       else
  1173.       begin
  1174.         For i := 1 to nhoriz DO
  1175.         begin
  1176.           nof := nof + 1;
  1177.           size[nof] := 4;
  1178.           facfront[nof] := last;
  1179.           faclist[last + 1] := index1[i + 1];
  1180.           faclist[last + 2] := index2[i + 2];
  1181.           faclist[last + 3] := index2[i];
  1182.           faclist[last + 4] := index1[i];
  1183.           last := last + size[nof];
  1184.           nfac[nof]     := nof;
  1185.           colour[nof]   := col;
  1186.           super[nof]    := 0;
  1187.           firstsup[nof] := 0;
  1188.         end;
  1189.       end
  1190.       else
  1191.       if index2[1] <> index2[2] then
  1192.         For i := 1 to nhoriz DO
  1193.         begin
  1194.           nof := nof + 1;
  1195.           size[nof] := 3;
  1196.           facfront[nof] := last;
  1197.           faclist[last + 1] := index2[i + 1];
  1198.           faclist[last + 2] := index2[i];
  1199.           faclist[last + 3] := index1[i];
  1200.           last := last + size[nof];
  1201.           nfac[nof]     := nof;
  1202.           colour[nof]   := col;
  1203.           super[nof]    := 0;
  1204.           firstsup[nof] := 0;
  1205.         end;
  1206.  
  1207.         For i :=  1 to nhoriz + 1 DO
  1208.           index1[i] := index2[i];
  1209.   end;
  1210.  
  1211.   For i :=  nov + 1 to newnov DO
  1212.     transform(setup[i], P, act[i]);
  1213.  
  1214.   nov := newnov;
  1215.  
  1216. end;
  1217.  
  1218. Procedure BressenHam( Virseg : Word;          { Adres-> VIRSEG:0 }
  1219.                       pnts   : pixelArray;
  1220.                       c      : Byte;          { c->     kleur    }
  1221.                       p1, p2 : pixelvector);  { vector           } Assembler;
  1222. Var
  1223.   x, y, error,
  1224.   s1,  s2,
  1225.   deltax,
  1226.   deltay, i   : Integer;
  1227.   interchange : Boolean;
  1228.   dcolor      : Word;
  1229. Asm
  1230. {  initialize Variables  }
  1231.   PUSH   ds
  1232.   LDS    si, pnts
  1233.   MOV    ax, virseg
  1234.   MOV    es, ax
  1235.   MOV    cx, 320
  1236.   MOV    ax, p1.x
  1237.   MOV    x,  ax
  1238.   MOV    ax, p1.y
  1239.   MOV    y, ax
  1240.   MOV    dcolor, ax
  1241.  
  1242.   MOV    ax, p2.x                { deltax := abs(x2 - x1) }
  1243.   SUB    ax, p1.x                { s1 := sign(x2 - x1) }
  1244.   PUSH   ax
  1245.   PUSH   ax
  1246.   CALL   ddVars.sign
  1247.   MOV    s1, ax;
  1248.   POP    ax
  1249.   TEST   ax, $8000
  1250.   JZ     @@GeenSIGN1
  1251.   NEG    ax
  1252.  @@GeenSign1:
  1253.   MOV    deltax, ax
  1254.   MOV    ax, p2.y
  1255.   SUB    ax, p1.y
  1256.   PUSH   ax
  1257.   PUSH   ax
  1258.   CALL   ddVars.sign
  1259.   MOV    s2, ax
  1260.   POP    ax
  1261.   TEST   ax, $8000
  1262.   JZ     @@GeenSign2
  1263.   NEG    ax
  1264.  @@GeenSign2:
  1265.   MOV    deltay, ax
  1266.  
  1267.  { Interchange DeltaX and DeltaY depending on the slope of the line }
  1268.  
  1269.   MOV    interchange, False
  1270.   CMP    ax, deltax
  1271.   JNG    @@NO_INTERCHANGE
  1272.   XCHG   ax, deltax
  1273.   XCHG   ax, deltay
  1274.   MOV    interchange, True
  1275.  
  1276.  @@NO_INTERCHANGE:
  1277.  
  1278.   { Initialize the error term to compensate For a nonzero intercept }
  1279.  
  1280.   MOV    ax, deltaY
  1281.   SHL    ax, 1
  1282.   SUB    ax, deltaX
  1283.   MOV    error, ax
  1284.  
  1285.   { Main loop }
  1286.   MOV    ax, 1
  1287.   MOV    i, ax
  1288.  @@FOR_begin:
  1289.   CMP    ax, deltaX
  1290.   JG     @@EINDE_FOR_LOOP
  1291.  
  1292.   { Plot punt! }
  1293.   MOV   bx, x
  1294.   MOV   ax, y
  1295.   MUL   cx
  1296.   ADD   bx, ax
  1297.   MOV   al, c
  1298.   MOV   Byte PTR [es:bx], al
  1299.   INC   [Word ptr ds:si]     { aantal verhogen }
  1300.   MOV   ax, [si]
  1301.   SHL   ax, 1                { offset berekenen }
  1302.   PUSH  si
  1303.   ADD   si, ax
  1304.   MOV   [si], bx
  1305.   POP   si
  1306.  
  1307.   { While Loop }
  1308.  @@W1_begin:
  1309.   CMP    error, 0
  1310.   JL     @@EINDE_WHILE
  1311.  
  1312.   { if interchange then }
  1313.  
  1314.   CMP    interchange, True
  1315.   JE     @@i_is_t
  1316.   MOV    ax, s2
  1317.   ADD    y, ax
  1318.   JMP    @@w1_eruit
  1319.  
  1320.  @@i_is_t:
  1321.   MOV    ax, s1
  1322.   ADD    x, ax
  1323.  
  1324.  @@w1_eruit:
  1325.   MOV    ax, deltax
  1326.   SHL    ax, 1
  1327.   SUB    error, ax
  1328.   JMP    @@w1_begin
  1329.  
  1330.  @@EINDE_WHILE:
  1331.   CMP    interchange, True
  1332.   JE     @@i_is_t_1
  1333.   MOV    ax, s1
  1334.   ADD    x, ax
  1335.   JMP    @@if_2_eruit
  1336.  
  1337.  @@i_is_t_1:
  1338.   MOV    ax, s2
  1339.   ADD    y, ax
  1340.  
  1341.  @@if_2_eruit:
  1342.   MOV    ax, deltay
  1343.   SHL    ax, 1
  1344.   ADD    error, ax
  1345.   INC    i
  1346.   MOV    ax, i
  1347.   JMP    @@FOR_begin
  1348.  @@Einde_for_loop:
  1349.   POP    ds
  1350. end;
  1351.  
  1352. Procedure linepto(c : Integer; pt1, pt2 : vector2);
  1353. Var
  1354.   p1, p2 : pixelvector;
  1355. begin
  1356.   p1.x := fx(pt1.x);
  1357.   p1.y := fy(pt1.y);
  1358.   p2.x := fx(pt2.x);
  1359.   p2.y := fy(pt2.y);
  1360.   BressenHam($a000, points, c,  p1,  p2);
  1361. end;
  1362.  
  1363. Procedure WisScherm(punten : pixelArray; SchermSeg , Virseg : Word); Assembler;
  1364. Asm
  1365.   PUSH      ds
  1366.   MOV       ax, SchermSeg
  1367.   MOV       es, ax
  1368.   LDS       bx, punten
  1369.   MOV       cx, [bx]
  1370.   JCXZ      @@NietTekenen
  1371.  @@Wis:
  1372.   INC       bx
  1373.   INC       bx
  1374.   MOV       si, [bx]
  1375.   MOV       di, si
  1376.   PUSH      ds
  1377.   MOV       ax, virseg
  1378.   MOV       ds, ax
  1379.   MOVSB
  1380.   POP       ds
  1381.   LOOP      @@Wis
  1382.  @@NietTekenen:
  1383.   POP       ds
  1384. end;
  1385.  
  1386. Procedure polydraw(c, n : Integer; poly : vector2Array);
  1387. Var
  1388.   i : Integer;
  1389. begin
  1390.   For i :=  1 to n - 1 do
  1391.     linepto(c, poly[i], poly[i + 1]);
  1392.   linepto(c, poly[n], poly[1]);
  1393. end;
  1394.  
  1395. Procedure fillpoly(c, n : Integer; poly : vector2Array);
  1396. Var
  1397.   scan_table : tabel;
  1398.   scanline,
  1399.   line,
  1400.   offsetx    : Integer;
  1401.  
  1402.   Procedure Draw_horiz_line(hline_ar  : hlineArray;
  1403.                             color     : Byte;
  1404.                             lijn      : Word;
  1405.                             begin_p   : Word;
  1406.                             linelen   : Word); Assembler;
  1407.   Asm
  1408.     PUSH  ds
  1409.     MOV   cx, 320
  1410.     MOV   ax, 0a000h
  1411.     MOV   es, ax
  1412.     MOV   di, begin_p
  1413.     MOV   ax, lijn
  1414.     MUL   cx
  1415.     ADD   di, ax
  1416.     PUSH  di
  1417.     MOV   al, color
  1418.     MOV   cx, linelen
  1419.     PUSH  cx
  1420.     REP   STOSB
  1421.     LDS   si, hline_ar
  1422.     INC   [Word ptr ds:si]
  1423.     MOV   ax, [si]
  1424.     SHL   ax, 1
  1425.     SHL   ax, 1
  1426.     ADD   si, ax
  1427.     POP   bx
  1428.     POP   dx
  1429.     MOV   [si], dx
  1430.     MOV   [si + 2], bx
  1431.     POP   ds
  1432.   end;
  1433.  
  1434.   Procedure swap(Var x, y : Integer);
  1435.   begin
  1436.     x := x + y;
  1437.     y := x - y;
  1438.     x := x - y;
  1439.   end;
  1440.  
  1441. {
  1442. Procedure Calc_x(x1, y1, x2, y2 : Word; Var scan_table : tabel);
  1443. Var
  1444.   m_inv,
  1445.   xReal : Real;
  1446. begin
  1447.   Asm
  1448.     LDS     dx, scan_table
  1449.     MOV     ax, y1
  1450.     MOV     bx, y2
  1451.     CMP     ax, bx
  1452.     JNE     @@NotHorizLine
  1453.     MOV     bx, x1
  1454.     SHL     ax, 1
  1455.     ADD     ax, dx
  1456.     CMP     bx, [dx]
  1457.     JGE     @@Notstorexmin
  1458.     MOV     [dx], bx
  1459.  
  1460.    @@Notstorexmin:
  1461.     INC     dx
  1462.     MOV     bx, x2
  1463.     CMP     bx, [dx]
  1464.     JLE     @@Klaar
  1465.     MOV     [dx], bx
  1466.     JMP     @@Klaar
  1467.  
  1468.    @@NotHorizLine:
  1469. }
  1470.  
  1471.   Procedure Calc_x(x1, y1, x2, y2 : Integer; Var scan_table : tabel);
  1472.   Var
  1473.     m_inv, xReal : Real;
  1474.     i, y, temp   : Integer;
  1475.   begin
  1476.     if y1 = y2 then
  1477.     begin
  1478.       if x2 < x1 then
  1479.         swap(x1, x2)
  1480.       else
  1481.       begin
  1482.         if x1 < scan_table[y1].xmin then
  1483.           scan_table[y1].xmin := x1;
  1484.         if x2 > scan_table[y2].xmax then
  1485.           scan_table[y2].xmax := x2;
  1486.       end;
  1487.     end
  1488.     else
  1489.     begin
  1490.       m_inv := (x2 - x1) / (y2 - y1);
  1491.  
  1492.       if y1 > y2 then {swap}
  1493.       begin
  1494.         swap(y1, y2);
  1495.         swap(x1, x2);
  1496.       end;
  1497.  
  1498.       if x1 < scan_table[y1].xmin then
  1499.         scan_table[y1].xmin := x1;
  1500.       if x2 > scan_table[y2].xmax then
  1501.         scan_table[y2].xmax := x2;
  1502.       xReal := x1; y := y1;
  1503.  
  1504.       While y < y2 do
  1505.       begin
  1506.         y := y + 1;
  1507.         xReal := xReal + m_inv;
  1508.         offsetx := round(xReal);
  1509.         if xReal < scan_table[y].xmin then
  1510.           scan_table[y].xmin := offsetx;
  1511.         if xReal > scan_table[y].xmax then
  1512.           scan_table[y].xmax := offsetx;
  1513.       end;
  1514.     end;
  1515.   end;
  1516.  
  1517. begin
  1518.   scan_table := emptytabel;
  1519.   For line := 1 to n - 1 do
  1520.     calc_x(fx(poly[line].x), fy(poly[line].y),
  1521.            fx(poly[line + 1].x), fy(poly[line + 1].y), scan_table);
  1522.  
  1523.   calc_x(fx(poly[n].x), fy(poly[n].y),
  1524.          fx(poly[1].x), fy(poly[1].y), scan_table);
  1525.  
  1526.   scanline := 0;
  1527.  
  1528.   While scanline < nypix - 1 do
  1529.   begin
  1530.     With Scan_table[scanline] DO
  1531.       if xmax > xmin then
  1532.         draw_horiz_line(hline, c,  scanline,  xmin,  xmax - xmin + 1);
  1533.       scanline := scanline + 1;
  1534.   end;
  1535. end;
  1536.  
  1537. Procedure  Wis_Hline(hline_ar : hlineArray; virseg : Word); Assembler;
  1538. Asm
  1539.   PUSH      ds
  1540.   MOV       ax, 0a000h
  1541.   MOV       es, ax
  1542.   LDS       bx, hline_ar
  1543.   MOV       cx, [bx]
  1544.   JCXZ      @@Niet_tekenen
  1545.   ADD       bx, 4
  1546.  @@Wis:
  1547.   XCHG      cx, dx
  1548.   MOV       si, [bx]
  1549.   MOV       cx, [bx + 2]
  1550.   MOV       di, si
  1551.   PUSH      ds
  1552.   MOV       ax, virseg
  1553.   MOV       ds, ax
  1554.   CLD
  1555.   REP       MOVSB
  1556.   POP       ds
  1557.   XCHG      cx, dx
  1558.   ADD       bx, 4
  1559.   LOOP      @@Wis
  1560.  @@Niet_tekenen:
  1561.   POP       ds
  1562. end;
  1563.  
  1564. begin
  1565. end.
  1566.  
  1567.  
  1568. { ▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒ }
  1569.  
  1570. Unit
  1571.   ddVars;
  1572.  
  1573. Interface
  1574.  
  1575. Const
  1576.   pi      = 3.1415926535;
  1577.   epsilon = 0.000001;
  1578.   rad     = pi / 180;
  1579.   nxpix   = 320; { scherm resolutie }
  1580.   nypix   = 200;
  1581.   maxfinf = 200;
  1582.  
  1583. Type
  1584.   xmaxymax  = Record xmin, xmax : Integer; end;
  1585.   facetinfo = Record info, Pointer : Integer; end;
  1586.   tabel     = Array [1..nypix - 1] of xmaxymax;
  1587.   sincos    = Array [0..359] of Real;
  1588.  
  1589. Var
  1590.   sinusArray   : sincos;
  1591.   cosinusArray : sincos;
  1592.   facetinfacet : Array [1..maxfinf] of facetinfo;
  1593.   facetfree    : Integer;
  1594.   xyscale      : Real;
  1595.   emptytabel   : tabel;
  1596.  
  1597. Function  fx(x : Real) : Integer;
  1598. Function  fy(y : Real) : Integer;
  1599. Function  Sign(I : Integer) : Integer;
  1600. Function  macht(a, n : Real) : Real;
  1601. Function  angle(x, y : Real) : Integer;
  1602. Function  sinus(hoek : Integer) : Real;
  1603. Function  cosin(hoek : Integer) : Real;
  1604. Procedure pushfacet(Var stackname : Integer; value : Integer);
  1605.  
  1606. Implementation
  1607.  
  1608. Function fx(x : Real) : Integer;
  1609. begin
  1610.   fx := nxpix - trunc(x * xyscale + nxpix * 0.5 - 0.5);
  1611. end;
  1612.  
  1613. Function fy(y : Real) : Integer;
  1614. begin
  1615.   fy := nypix - trunc(y * xyscale + nypix * 0.5 - 0.5);
  1616. end;
  1617.  
  1618. Function Sign(I : Integer) : Integer; Assembler;
  1619. Asm
  1620.   MOV  ax, i
  1621.   CMP  ax, 0
  1622.   JGE  @@Zero_or_one
  1623.   MOV  ax, -1
  1624.   JMP  @@Exit
  1625.  
  1626.  @@Zero_or_One:
  1627.   JE   @@Nul
  1628.   MOV  ax, 1
  1629.   JMP  @@Exit
  1630.  
  1631.  @@Nul:
  1632.   xor  ax, ax
  1633.  
  1634.  @@Exit:
  1635. end;
  1636.  
  1637. Function macht(a, n : Real) : Real;
  1638. begin
  1639.   if a > 0 then
  1640.     macht :=  exp(n * (ln(a)))
  1641.   else
  1642.   if a < 0 then
  1643.     macht := -exp(n * (ln(-a)))
  1644.   else
  1645.     macht := a;
  1646. end;
  1647.  
  1648. Function angle(x, y : Real) : Integer;
  1649. begin
  1650.   if abs(x) < epsilon then
  1651.     if abs(y) < epsilon then
  1652.       angle := 0
  1653.     else
  1654.     if y > 0.0 then
  1655.       angle := 90
  1656.     else
  1657.       angle := 270
  1658.   else
  1659.   if x < 0.0 then
  1660.     angle := round(arctan(y / x) / rad) + 180
  1661.   else
  1662.     angle := round(arctan(y / x) / rad);
  1663. end;
  1664.  
  1665. Function sinus(hoek : Integer) : Real;
  1666. begin
  1667.   hoek  := hoek mod 360;
  1668.   sinus := sinusArray[hoek];
  1669. end;
  1670.  
  1671. Function cosin(hoek : Integer) : Real;
  1672. begin
  1673.   hoek  := hoek mod 360 ;
  1674.   cosin := cosinusArray[hoek];
  1675. end;
  1676.  
  1677. Procedure pushfacet(Var stackname : Integer; value : Integer);
  1678. Var
  1679.   location : Integer;
  1680. begin
  1681.   if facetfree = 0 then
  1682.   begin
  1683.     Write('Cannot hold more facets');
  1684.     HALT;
  1685.   end
  1686.   else
  1687.   begin
  1688.     location  := facetfree;
  1689.     facetfree := facetinfacet[facetfree].Pointer;
  1690.     facetinfacet[location].info := value;
  1691.     facetinfacet[location].Pointer := stackname;
  1692.     stackname := location;
  1693.   end;
  1694. end;
  1695.  
  1696. Var
  1697.   i : Integer;
  1698. begin
  1699.   { vul sinus- en cosinusArray met waarden }
  1700.   For i := 0 to 359 DO
  1701.   begin
  1702.     sinusArray[i]   := sin(i * rad);
  1703.     cosinusArray[i] := cos(i * rad);
  1704.   end;
  1705.   { Init facetinfacet }
  1706.   facetfree := 1;
  1707.   For i :=  1 to maxfinf - 1 DO
  1708.     facetinfacet[i].Pointer := i + 1;
  1709.  
  1710.   facetinfacet[maxfinf].Pointer := 0;
  1711.  
  1712.   { Init EmptyTabel }
  1713.   For i := 0 to nypix - 1 DO
  1714.   begin
  1715.     Emptytabel[i].xmin := 319;
  1716.     Emptytabel[i].xmax := 0;
  1717.   end;
  1718. end.
  1719.  
  1720.  
  1721. { ▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒ }
  1722.  
  1723. Unit ddvideo;
  1724.  
  1725. Interface
  1726.  
  1727. Uses
  1728.   Dos, DDVars;
  1729.  
  1730. Type
  1731.   schermPointer = ^schermType;
  1732.   schermType    = Array [0..nypix - 1, 0..nxpix - 1] of Byte;
  1733.   color         = Record  R, G, B : Byte; end;
  1734.   paletteType   = Array [0..255] of color;
  1735.   WordArray     = Array [0..3] of Word;
  1736.   palFile       = File of paletteType;
  1737.   picFile       = File of schermType;
  1738.  
  1739. Var
  1740.   scherm    : schermType Absolute $8A00 : $0000;
  1741.   schermptr : schermPointer;
  1742.   switch    : Integer;
  1743.  
  1744. Procedure start(Filenaam : String; horiz : Real; Var Oldpal : paletteType);
  1745. Procedure finish(Oldpal : paletteType);
  1746. Procedure VirScherm_actief(switch : Word);
  1747. Procedure Scherm_actief(switch : Word);
  1748.  
  1749. Implementation
  1750.  
  1751. Procedure Virscherm_actief(switch : Word); Assembler;
  1752. Asm
  1753.   MOV     dx, 3cch
  1754.   MOV     cx, switch
  1755.   JCXZ    @@volgende
  1756.   in      al, dx             { switch=1 }
  1757.   and     al, 0dfh
  1758.   MOV     dx, 3c2h
  1759.   OUT     dx, al             { set even mode }
  1760.   JMP     @@Klaar
  1761.  
  1762.  @@Volgende:
  1763.   in      al, dx             { switch=0 }
  1764.   or      al, 20h
  1765.   MOV     dx, 3c2h
  1766.   OUT     dx, al             { set odd mode }
  1767.  
  1768.  @@Klaar:
  1769.   MOV     dx, 3dah           { Wacht op Vert-retrace }
  1770.   in      al, dx             { Zodat virscherm = invisible }
  1771.   TEST    al, 08h
  1772.   JZ      @@Klaar
  1773. end;
  1774.  
  1775. Procedure Scherm_actief(switch : Word);
  1776. begin
  1777.   Asm
  1778.    @@Wacht:
  1779.     MOV  dx, 3dah
  1780.     in   al, dx
  1781.     TEST al, 01h
  1782.     JNZ  @@Wacht
  1783.   end;
  1784.   port[$3d4] := $c;
  1785.   port[$3d5] := switch * $80;
  1786. end;
  1787.  
  1788. Procedure SetVgaPalette(Var p : paletteType);
  1789. Var
  1790.   regs : Registers;
  1791. begin
  1792.   With regs do
  1793.   begin
  1794.     ax := $1012;
  1795.     bx := 0;
  1796.     cx := 256;
  1797.     es := seg(p);
  1798.     dx := ofs(p);
  1799.   end;
  1800.   intr ($10, regs);
  1801. end;
  1802.  
  1803.  
  1804. Procedure start(Filenaam : String; horiz : Real; Var Oldpal : paletteType);
  1805.  
  1806.   Procedure readimage(Filenaam : String; Var pal : paletteType);
  1807.  
  1808.     Function FileExists(FileName : String) : Boolean;
  1809.     Var
  1810.       f : File;
  1811.     begin
  1812.       {$I-}
  1813.       Assign(f,  FileName);
  1814.       Reset(f);
  1815.       Close(f);
  1816.       {$I + }
  1817.       FileExists := (IOResult = 0) and (FileName <> '');
  1818.     end;
  1819.  
  1820.   Var
  1821.     pFile : picFile;
  1822.     lFile : palFile;
  1823.     a     : Integer;
  1824.   begin
  1825.     if (FileExists(Filenaam + '.pal')) and
  1826.        (FileExists(Filenaam + '.dwg')) then
  1827.     begin
  1828.       assign(lFile, Filenaam + '.pal');
  1829.       reset(lFile);
  1830.       read(lFile, pal);
  1831.       close(lFile);
  1832.       assign(pFile, Filenaam + '.dwg');
  1833.       reset(pFile);
  1834.       read(pFile, schermptr^);
  1835.       close(pFile);
  1836.     end
  1837.     else
  1838.     begin
  1839.       Writeln('Palette en Picture bestanden niet gevonden....');
  1840.       Halt;
  1841.     end;
  1842.   end;
  1843.  
  1844.   Procedure SetVgaMode; Assembler;
  1845.   Asm
  1846.     mov  ah, 0
  1847.     mov  al, 13h
  1848.     int  $10
  1849.   end;
  1850.  
  1851.   Procedure GetVgaPalette(Var p : paletteType);
  1852.   Var
  1853.     regs : Registers;
  1854.   begin
  1855.     With regs do
  1856.     begin
  1857.       ax := $1017;
  1858.       bx := 0;
  1859.       cx := 256;
  1860.       es := seg(p);
  1861.       dx := ofs(p);
  1862.     end;
  1863.     intr ($10, regs);
  1864.   end;
  1865.  
  1866. Var
  1867.   pal : paletteType;
  1868.  
  1869. begin
  1870.   getmem(schermptr, sizeof(schermType));
  1871.   readimage(Filenaam, pal);
  1872.   GetVgaPalette(OldPal);
  1873.   SetVgaPalette(pal);
  1874.   SetVgaMode;
  1875.   move(schermptr^, scherm, nypix * nxpix);
  1876.   Virscherm_actief(0);
  1877.   move(schermptr^, mem[$A000 : 0], nypix * nxpix);     { blanko scherm }
  1878.   VirScherm_actief(1);
  1879.   move(schermptr^, mem[$A000 : 0], nypix * nxpix);     { blanko scherm }
  1880.   Scherm_actief(1);
  1881.   switch  := 0;
  1882.   xyscale := (nypix - 1) / horiz;
  1883. end;
  1884.  
  1885. Procedure finish(Oldpal : paletteType);
  1886.  
  1887.   Procedure SetNormalMode; Assembler;
  1888.   Asm
  1889.     mov  ah,  0
  1890.     mov  al,  3
  1891.     int  $10
  1892.   end;
  1893.  
  1894. begin
  1895.   SetVgaPalette(Oldpal);
  1896.   SetNormalMode;
  1897.   Virscherm_actief(0);
  1898.   Freemem(schermptr, sizeof(schermType));
  1899. end;
  1900.  
  1901. begin
  1902. end.
  1903.